home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / language / ici / ici.cpi / cfunc.c < prev    next >
C/C++ Source or Header  |  1994-10-27  |  47KB  |  2,552 lines
  1. #include "exec.h"
  2. #include "func.h"
  3. #include "str.h"
  4. #include "int.h"
  5. #include "float.h"
  6. #include "struct.h"
  7. #include "set.h"
  8. #include "op.h"
  9. #include "ptr.h"
  10. #include "buf.h"
  11. #include "file.h"
  12. #include "re.h"
  13. #include "null.h"
  14. #include "parse.h"
  15. #include "mem.h"
  16. #include <stdio.h>
  17. #include <math.h>
  18. #include <ctype.h>
  19. #include <errno.h>
  20. #include <stdarg.h>
  21.  
  22. #ifndef    NOWAITFOR
  23. /*
  24.  * For select() for waitfor().
  25.  */
  26. #include <sys/types.h>
  27.  
  28. #ifdef    BSD
  29. #include <sys/time.h>
  30. #else
  31. # ifdef mips
  32. #  include <bsd/sys/types.h>
  33. #  include <bsd/sys/time.h>
  34. # else
  35. #  ifdef hpux
  36. #   include <time.h>
  37. #  else
  38. #   ifndef _R3000
  39. #    include <sys/select.h>
  40. #    include <sys/times.h>
  41. #   endif
  42. #  endif
  43. # endif
  44. #  define    bzero(p,n)    (memset((p), 0, (n)))
  45. # endif
  46. #endif
  47.  
  48. #if defined(sun) && defined(__GNUC__) || !__STDC__
  49. extern int    fgetc();
  50. #endif
  51.  
  52. /*
  53.  * typecheck(argspec, &arg1, &arg2...)
  54.  *
  55.  * Check ICI/C function argument types and translate into normal C data types.
  56.  * The argspec is a character string.  Each character corresponds to
  57.  * an actual argument to the ICI function which will (may) be assigned
  58.  * through the corresponding pointer taken from the subsequent arguments.
  59.  * Any detected type mismatches result in a non-zero return.  If all types
  60.  * match, all assignments will be made and zero will be returned.
  61.  *
  62.  * The argspec key letters and their meaning are:
  63.  *
  64.  * o    Any ICI object is required in the actuals, the corresponding pointer
  65.  *    must be a pointer to a (object_t *); which will be set to the actual
  66.  *    argument.
  67.  * p    An ICI ptr object is required in the actuals, then as for o.
  68.  * d    An ICI struct object is required in the actuals, then as for o.
  69.  * a    An ICI array object is required in the actuals, then as for o.
  70.  * u    An ICI file object is required in the actuals, then as for o.
  71.  * i    An ICI int object is required in the actuals, the value of this int
  72.  *    will be stored through the corresponding pointer which must be
  73.  *    a (long *).
  74.  * f    An ICI float object is required in the actuals, the value of this float
  75.  *    will be stored through the corresponding pointer which must be
  76.  *    a (double *).
  77.  * n    An ICI float or int object is required in the actuals, the value of
  78.  *    this float or int will be stored through the corresponding pointer
  79.  *    which must be a (double *).
  80.  * s    An ICI string object is required in the actuals, the corresponding
  81.  *    pointer must be a (char **).  A pointer to the raw characters of
  82.  *    the string will be stored through this (this will be '\0' terminated
  83.  *    by virtue of all ICI strings having a gratuitous '\0' just past
  84.  *    their real end).
  85.  * -    The acutal parameter at this position is skipped, but it must be
  86.  *    present.
  87.  * *    All remaining actual parametes are ignored (even if there aren't any).
  88.  *
  89.  * The capitalisation of any of the alphabetic key letters above changes
  90.  * their meaning.  The acutal must be an ICI ptr type.  The value this
  91.  * pointer points to is taken to be the value which the above descriptions
  92.  * concern themselves with (i.e. in place of the raw actual parameter).
  93.  *
  94.  * There must be exactly as many actual arguments as key letters unless
  95.  * the last key letter is a *.
  96.  *
  97.  * Error returns have the usual ICI error conventions.
  98.  */
  99. int
  100. typecheck(char *types, ...)
  101. {
  102.     va_list        va;
  103.     register object_t    **ap;    /* Argument pointer. */
  104.     register int    nargs;
  105.     register int    i;    
  106.     char        *ptr;    /* Subsequent things from va_alist. */
  107.     register int    tcode;
  108.     register object_t    *o;
  109.  
  110.     va_start(va, types);
  111.     nargs = NARGS();
  112.     ap = ARGS();
  113.     for (i = 0; types[i] != '\0'; ++i, --ap)
  114.     {
  115.     if (types[i] == '*')
  116.     {
  117.         va_end(va);
  118.         return 0;
  119.     }
  120.  
  121.     if (i == nargs)
  122.     {
  123.         va_end(va);
  124.         return argcount(strlen(types));
  125.     }
  126.  
  127.     if ((tcode = types[i]) == '-')
  128.         continue;
  129.  
  130.     ptr = va_arg(va, char *);
  131.     if (tcode >= 'A' && tcode <= 'Z')
  132.     {
  133.         if (!isptr(*ap))
  134.         goto fail;
  135.         if ((o = fetch(*ap, objof(o_zero))) == NULL)
  136.         goto fail;
  137.         tcode += 'a' - 'A';
  138.     }
  139.     else
  140.     {
  141.         o = *ap;
  142.     }
  143.  
  144.     switch (tcode)
  145.     {
  146.     case 'o': /* Any object. */
  147.         *(object_t **)ptr = o;
  148.         break;
  149.  
  150.     case 'p': /* Any pointer. */
  151.         if (!isptr(o))
  152.         goto fail;
  153.         *(ptr_t **)ptr = ptrof(o);
  154.         break;
  155.  
  156.     case 'i': /* An int -> int. */
  157.         if (!isint(o))
  158.         goto fail;
  159.         *(long *)ptr = intof(o)->i_value;
  160.         break;
  161.  
  162.     case 's': /* A string -> (char *). */
  163.         if (!isstring(o))
  164.         goto fail;
  165.         *(char **)ptr = stringof(o)->s_chars;
  166.         break;
  167.  
  168.     case 'f': /* A float -> double. */
  169.         if (!isfloat(o))
  170.         goto fail;
  171.         *(double *)ptr = floatof(o)->f_value;
  172.         break;
  173.  
  174.     case 'n': /* A number, int or float -> double. */
  175.         if (isint(o))
  176.         *(double *)ptr = intof(o)->i_value;
  177.         else if (isfloat(o))
  178.         *(double *)ptr = floatof(o)->f_value;
  179.         else
  180.         goto fail;
  181.         break;
  182.  
  183.     case 'd': /* A struct ("dict") -> (struct_t *). */
  184.         if (!isstruct(o))
  185.         goto fail;
  186.         *(struct_t **)ptr = structof(o);
  187.         break;
  188.  
  189.     case 'a': /* An array -> (array_t *). */
  190.         if (!isarray(o))
  191.         goto fail;
  192.         *(array_t **)ptr = arrayof(o);
  193.         break;
  194.  
  195.     case 'u': /* A file -> (file_t *). */
  196.         if (!isfile(o))
  197.         goto fail;
  198.         *(file_t **)ptr = fileof(o);
  199.         break;
  200.  
  201.     case 'r': /* A regular expression -> (regexpr_t *). */
  202.         if (!isregexp(o))
  203.         goto fail;
  204.         *(regexp_t **)ptr = regexpof(o);
  205.         break;
  206.     }
  207.     }
  208.     va_end(va);
  209.     if (i != nargs)
  210.     return argcount(i);
  211.     return 0;
  212.  
  213. fail:
  214.     return argerror(i);
  215. }
  216.  
  217. /*
  218.  * retcheck(retspec, &arg1, &arg2...)
  219.  *
  220.  * Perform storage of values through pointers in the actual arguments to
  221.  * an ICI/C function.
  222.  *
  223.  * The retspec is a character string consisting of key letters which
  224.  * correspond to actual arguments of the current ICI/C function.
  225.  * Each of the characters in the retspec has the following meaning.
  226.  *
  227.  * o    The actual argument must be a ptr, the corresponding pointer is
  228.  *    assumed to be an (object_t **).  The location indicated by the
  229.  *    ptr object is updated with the (object_t *).
  230.  * d
  231.  * a
  232.  * u    Likwise for types as per typecheck() above.
  233.  * ...
  234.  * -    The acutal argument is skipped.
  235.  * *    ...
  236.  */
  237. int
  238. retcheck(char *types, ...)
  239. {
  240.     va_list        va;
  241.     register int    i;
  242.     register int    nargs;    
  243.     register object_t    **ap;
  244.     char        *ptr;
  245.     register int    tcode;
  246.     register object_t    *o;
  247.     register object_t    *s;
  248.  
  249.     va_start(va, types);
  250.     nargs = NARGS();
  251.     ap = ARGS();
  252.     for (i = 0; types[i] != '\0'; ++i, --ap)
  253.     {
  254.     if ((tcode = types[i]) == '*')
  255.     {
  256.         va_end(va);
  257.         return 0;
  258.     }
  259.  
  260.     if (i == nargs)
  261.     {
  262.         va_end(va);
  263.         return argcount(strlen(types));
  264.     }
  265.  
  266.     if (tcode == '-')
  267.         continue;
  268.  
  269.     o = *ap;
  270.     if (!isptr(o))
  271.         goto fail;
  272.  
  273.     ptr = va_arg(va, char *);
  274.  
  275.     switch (tcode)
  276.     {
  277.     case 'o': /* Any object. */
  278.         *(object_t **)ptr = o;
  279.         break;
  280.  
  281.     case 'p': /* Any pointer. */
  282.         if (!isptr(o))
  283.         goto fail;
  284.         *(ptr_t **)ptr = ptrof(o);
  285.         break;
  286.  
  287.     case 'i':
  288.         if ((s = objof(new_int(*(long *)ptr))) == NULL)
  289.         goto ret1;
  290.         if (assign(o, objof(o_zero), s))
  291.         goto ret1;
  292.         loose(s);
  293.         break;
  294.  
  295.     case 's':
  296.         if ((s = objof(new_cname(*(char **)ptr))) == NULL)
  297.         goto ret1;
  298.         if (assign(o, objof(o_zero), s))
  299.         goto ret1;
  300.         loose(s);
  301.         break;
  302.  
  303.     case 'f':
  304.         if ((s = objof(new_float(*(double *)ptr))) == NULL)
  305.         goto ret1;
  306.         if (assign(o, objof(o_zero), s))
  307.         goto ret1;
  308.         loose(s);
  309.         break;
  310.  
  311.     case 'd':
  312.         if (!isstruct(o))
  313.         goto fail;
  314.         *(struct_t **)ptr = structof(o);
  315.         break;
  316.  
  317.     case 'a':
  318.         if (!isarray(o))
  319.         goto fail;
  320.         *(array_t **)ptr = arrayof(o);
  321.         break;
  322.  
  323.     case 'u':
  324.         if (!isfile(o))
  325.         goto fail;
  326.         *(file_t **)ptr = fileof(o);
  327.         break;
  328.  
  329.     case '*':
  330.         return 0;
  331.  
  332.     }
  333.     }
  334.     va_end(va);
  335.     if (i != nargs)
  336.     return argcount(i);
  337.     return 0;
  338.  
  339. ret1:
  340.     va_end(va);
  341.     return 1;
  342.  
  343. fail:
  344.     va_end(va);
  345.     return argerror(i);
  346. }
  347.  
  348. int
  349. argerror(i)
  350. int    i;
  351. {
  352.     char    n[30];
  353.  
  354.     sprintf(buf, "argument %d of %s() incorrectly supplied as %s",
  355.     i + 1,
  356.     cfuncof(o_top[-1])->cf_name,
  357.     objname(n, ARG(i)));
  358.     error = buf;
  359.     return 1;
  360. }
  361.  
  362. int
  363. argcount(n)
  364. int    n;
  365. {
  366.     sprintf(buf, "%d arguments given to %s, but it takes %d",
  367.     NARGS(), cfuncof(o_top[-1])->cf_name, n);
  368.     error = buf;
  369.     return 1;
  370. }
  371.  
  372. /*
  373.  * General way out of intrinsic functions, but only if the object is non-loose.
  374.  * Also allows NULL and does the error return.
  375.  */
  376. int
  377. obj_ret(o)
  378. object_t    *o;
  379. {
  380.     if (o == NULL)
  381.     return 1;
  382.     o_top -= NARGS();
  383.     o_top[-1] = o;
  384.     loose(o);
  385.     --x_top;
  386.     return 0;
  387. }
  388.  
  389. /*
  390.  * Return method for loose objects out of intrinsic functions.
  391.  */
  392. int
  393. loose_ret(o)
  394. object_t    *o;
  395. {
  396.     o_top -= NARGS();
  397.     o_top[-1] = o;
  398.     --x_top;
  399.     return 0;
  400. }
  401.  
  402. int
  403. int_ret(ret)
  404. long    ret;
  405. {
  406.     return obj_ret(objof(new_int(ret)));
  407. }
  408.  
  409. int
  410. str_ret(str)
  411. char    *str;
  412. {
  413.     return obj_ret(objof(new_cname(str)));
  414. }
  415.  
  416. file_t *
  417. need_stdin()
  418. {
  419.     file_t        *f;
  420.     static string_t    *string_stdin;
  421.  
  422.     if (need_string(&string_stdin, "stdin"))
  423.     return NULL;
  424.     f = fileof(fetch(v_top[-1], string_stdin));
  425.     if (!isfile(f))
  426.     {
  427.     error = "stdin is not a file";
  428.     return NULL;
  429.     }
  430.     return f;
  431. }
  432.  
  433. file_t *
  434. need_stdout()
  435. {
  436.     file_t        *f;
  437.     static string_t    *string_stdout;
  438.  
  439.     if (need_string(&string_stdout, "stdout"))
  440.     return NULL;
  441.     f = fileof(fetch(v_top[-1], string_stdout));
  442.     if (!isfile(f))
  443.     {
  444.     error = "stdout is not a file";
  445.     return NULL;
  446.     }
  447.     return f;
  448. }
  449.  
  450. #ifndef    NOMATH
  451.  
  452. #if !__STDC__
  453. # ifdef sun
  454. /*
  455.  * Math exception handler for SVID compliant systems. We just set errno
  456.  * to the appropriate value and return non-zero. This stops the output
  457.  * of a message to stderr and allows normal error handling to control
  458.  * the behaviour.
  459.  */
  460. int
  461. matherr(exc)
  462. struct exception *exc;
  463. {
  464.     switch (exc->type)
  465.     {
  466.     case DOMAIN:
  467.     case SING:
  468.     errno = EDOM;
  469.     break;
  470.     case OVERFLOW:
  471.     case UNDERFLOW:
  472.     errno = ERANGE;
  473.     break;
  474.     }
  475.     return 1;
  476. }
  477. # endif
  478. #endif
  479.  
  480. /*
  481.  * For any C functions that return a double and take 0, 1, or 2 doubles as
  482.  * arguments.
  483.  */
  484. int
  485. f_math()
  486. {
  487.     double    av[2];
  488.     double    r;
  489.  
  490.     if (typecheck(CF_ARG2() + 2, &av[0], &av[1]))
  491.     return 1;
  492.     errno = 0;
  493.     r = (*(double (*)())CF_ARG1())(av[0], av[1]);
  494.     if (errno != 0)
  495.     {
  496.     error = syserr();
  497.     return 1;
  498.     }
  499.     return obj_ret(objof(new_float(r)));
  500. }
  501. #endif
  502.  
  503. STATIC int
  504. f_struct()
  505. {
  506.     register object_t    **o;
  507.     register int    nargs;
  508.     register struct_t    *s;
  509.     register struct_t    *super;
  510.  
  511.     nargs = NARGS();
  512.     o = ARGS();
  513.     super = NULL;
  514.     if (nargs & 1)
  515.     {
  516.     if (!(isstruct(objof(super = structof(*o)))))
  517.         return argerror(0);
  518.     --nargs;
  519.     --o;
  520.     }
  521.     if ((s = new_struct()) == NULL)
  522.     return 1;
  523.     for (; nargs >= 2; nargs -= 2, o -= 2)
  524.     {
  525.     if (assign(s, o[0], o[-1]))
  526.     {
  527.         loose(s);
  528.         return 1;
  529.     }
  530.     }
  531.     s->s_super = super;
  532.     return obj_ret(objof(s));
  533. }
  534.  
  535. STATIC int
  536. f_set()
  537. {
  538.     register int    nargs;
  539.     register set_t    *s;
  540.     register object_t    **o;
  541.  
  542.     if ((s = new_set()) == NULL)
  543.     return 1;
  544.     for (nargs = NARGS(), o = ARGS(); nargs > 0; --nargs, --o)
  545.     {
  546.     if (assign(s, *o, objof(o_one)))
  547.     {
  548.         loose(s);
  549.         return 1;
  550.     }
  551.     }
  552.     return obj_ret(objof(s));
  553. }
  554.  
  555. STATIC int
  556. f_array()
  557. {
  558.     register int    nargs;
  559.     register array_t    *a;
  560.     register object_t    **o;
  561.  
  562.     if ((a = new_array()) == NULL)
  563.     return 1;
  564.     nargs = NARGS();
  565.     if (pushcheck(a, nargs))
  566.     return 1;
  567.     for (o = ARGS(); nargs > 0; --nargs)
  568.     *a->a_top++ = *o--;
  569.     return obj_ret(objof(a));
  570. }
  571.  
  572. STATIC int
  573. f_keys()
  574. {
  575.     struct_t        *s;
  576.     register array_t    *k;
  577.     register slot_t    *sl;
  578.  
  579.     if (typecheck("d", &s))
  580.     return 1;
  581.     if ((k = new_array()) == NULL)
  582.     return 1;
  583.     if (pushcheck(k, s->s_nels))
  584.     {
  585.     loose(k);
  586.     return 1;
  587.     }
  588.     for (sl = s->s_slots; sl < s->s_slots + s->s_nslots; ++sl)
  589.     {
  590.     if (sl->sl_key != NULL)
  591.         *k->a_top++ = sl->sl_key;
  592.     }
  593.     return obj_ret(objof(k));
  594. }
  595.  
  596. STATIC int
  597. f_copy()
  598. {
  599.     if (NARGS() != 1)
  600.     return argcount(1);
  601.     return obj_ret(copy(ARG(0)));
  602. }
  603.  
  604. STATIC int
  605. f_regexp()
  606. {
  607.     char        *s;
  608.     extern regexp_t    *new_regexp();
  609.  
  610.     if (typecheck("s", &s))
  611.     return 1;
  612.     return obj_ret(objof(new_regexp(s)));
  613. }
  614.  
  615. STATIC int
  616. f_typeof()
  617. {
  618.     if (NARGS() != 1)
  619.     return argcount(1);
  620.     return str_ret(ARG(0)->o_type->t_name);
  621. }
  622.  
  623. STATIC int
  624. f_nels()
  625. {
  626.     register object_t    *o;
  627.     long        size;
  628.  
  629.     if (NARGS() != 1)
  630.     return argcount(1);
  631.     o = ARG(0);
  632.     if (isstring(o))
  633.     size = stringof(o)->s_nchars;
  634.     else if (isarray(o))
  635.     size = arrayof(o)->a_top - arrayof(o)->a_base;
  636.     else if (isstruct(o))
  637.     size = structof(o)->s_nels;
  638.     else if (isset(o))
  639.     size = setof(o)->s_nels;
  640.     else if (ismem(o))
  641.     size = memof(o)->m_length;
  642.     else
  643.     size = 1;
  644.     return int_ret(size);
  645. }
  646.  
  647. STATIC int
  648. f_int()
  649. {
  650.     register object_t    *o;
  651.     register long    v;
  652. #ifndef __STDC__
  653.     extern long        strtol();
  654. #endif
  655.     if (NARGS() != 1)
  656.     return argcount(1);
  657.     o = ARG(0);
  658.     if (isint(o))
  659.     return loose_ret(o);
  660.     else if (isstring(o))
  661.     v = strtol(stringof(o)->s_chars, NULL, 0);
  662.     else if (isfloat(o))
  663.     v = (long)floatof(o)->f_value;
  664.     else
  665.     v = 0;
  666.     return int_ret(v);
  667. }
  668.  
  669. STATIC int
  670. f_float()
  671. {
  672.     register object_t    *o;
  673.     register double    v;
  674.     extern double    strtod();
  675.  
  676.     if (NARGS() != 1)
  677.     return argcount(1);
  678.     o = ARG(0);
  679.     if (isfloat(o))
  680.     return loose_ret(o);
  681.     else if (isstring(o))
  682.     v = strtod(stringof(o)->s_chars, NULL);
  683.     else if (isint(o))
  684.     v = (double)intof(o)->i_value;
  685.     else
  686.     v = 0;
  687.     return obj_ret(objof(new_float(v)));
  688. }
  689.  
  690. STATIC int
  691. f_num()
  692. {
  693.     register object_t    *o;
  694.     register double    f;
  695.     register long    i;
  696.     char        *s;
  697.     extern double    strtod();
  698.     char        n[30];
  699.  
  700.     if (NARGS() != 1)
  701.     return argcount(1);
  702.     o = ARG(0);
  703.     if (isfloat(o) || isint(o))
  704.     return loose_ret(o);
  705.     else if (isstring(o))
  706.     {
  707.     i = strtol(stringof(o)->s_chars, &s, 0);
  708.     if (*s == '\0')
  709.         return int_ret(i);
  710.     f = strtod(stringof(o)->s_chars, &s);
  711.     if (*s == '\0')
  712.         return obj_ret(objof(new_float(f)));
  713.     }
  714.     sprintf(buf, "%s is not a number", objname(n, o));
  715.     error = buf;
  716.     return 1;
  717. }
  718.  
  719. STATIC int
  720. f_string()
  721. {
  722.     register object_t    *o;
  723.  
  724.     if (NARGS() != 1)
  725.     return argcount(1);
  726.     o = ARG(0);
  727.     if (isstring(o))
  728.     return loose_ret(o);
  729.     if (isint(o))
  730.     sprintf(buf, "%ld", intof(o)->i_value);
  731.     else if (isfloat(o))
  732.     sprintf(buf, "%g", floatof(o)->f_value);
  733.     else
  734.     sprintf(buf, "<%s>", o->o_type->t_name);
  735.     return str_ret(buf);
  736. }
  737.  
  738. STATIC int
  739. f_eq()
  740. {
  741.     object_t    *o1;
  742.     object_t    *o2;
  743.  
  744.     if (typecheck("oo", &o1, &o2))
  745.     return 1;
  746.     if (o1 == o2)
  747.     return loose_ret(objof(o_one));
  748.     return loose_ret(objof(o_zero));
  749. }
  750.  
  751. STATIC int
  752. f_push()
  753. {
  754.     array_t    *s;
  755.     object_t    *o;
  756.  
  757.     if (typecheck("ao", &s, &o))
  758.     return 1;
  759.     if (objof(s)->o_flags & O_ATOM)
  760.     {
  761.     error = "attempt to push atomic array";
  762.     return 1;
  763.     }
  764.     if (pushcheck(s, 1))
  765.     return 1;
  766.     *s->a_top++ = o;
  767.     return loose_ret(o);
  768. }
  769.  
  770. STATIC int
  771. f_pop()
  772. {
  773.     array_t    *s;
  774.  
  775.     if (typecheck("a", &s))
  776.     return 1;
  777.     if (objof(s)->o_flags & O_ATOM)
  778.     {
  779.     error = "attempt to pop atomic array";
  780.     return 1;
  781.     }
  782.     if (popcheck(s, 1))
  783.     return loose_ret(objof(&o_null));
  784.     return loose_ret(*--s->a_top);
  785. }
  786.  
  787. STATIC int
  788. f_top()
  789. {
  790.     array_t    *s;
  791.     long    n = 0;
  792.  
  793.     switch (NARGS())
  794.     {
  795.     case 1:
  796.     if (typecheck("a", &s))
  797.     return 1;
  798.     break;
  799.     default:
  800.     if (typecheck("ai", &s, &n))
  801.     return 1;
  802.     if (n > 0)
  803.         goto retnull;
  804.     if (popcheck(s, 1-n))
  805.         goto retnull;
  806.     }
  807.     if (popcheck(s, 1+n))
  808.     goto retnull;
  809.     return loose_ret(s->a_top[-1+n]);
  810.  
  811. retnull:
  812.     return loose_ret(objof(&o_null));
  813. }
  814.  
  815. STATIC int
  816. f_parse()
  817. {
  818.     object_t    *o;
  819.     file_t    *f;
  820.     struct_t    *s;    /* Statics. */
  821.     struct_t    *a;    /* Autos. */
  822.  
  823.     switch (NARGS())
  824.     {
  825.     case 1:
  826.     if (typecheck("o", &o))
  827.         return 1;
  828.     if ((a = new_struct()) == NULL)
  829.         return 1;
  830.     if ((a->s_super = s = new_struct()) == NULL)
  831.         return 1;
  832.     loose(s);
  833.     s->s_super = structof(v_top[-1])->s_super;
  834.     break;
  835.     
  836.     default:
  837.     if (typecheck("od", &o, &a))
  838.         return 1;
  839.     got(a);
  840.     break;
  841.     }
  842.  
  843.     if (isstring(o))
  844.     {
  845.     if ((f = sopen(stringof(o)->s_chars, stringof(o)->s_nchars)) == NULL)
  846.     {
  847.         loose(a);
  848.         return 1;
  849.     }
  850.     f->f_name = get_cname("");
  851.     }
  852.     else if (isfile(o))
  853.     f = fileof(o);
  854.     else
  855.     {
  856.     loose(a);
  857.     return argerror(0);
  858.     }
  859.  
  860.     if (parse_module(f, a) < 0)
  861.     goto fail;
  862.  
  863.     if (isstring(o))
  864.     loose(f);
  865.     return obj_ret(objof(a));
  866.  
  867. fail:
  868.     if (isstring(o))
  869.     loose(f);
  870.     loose(a);
  871.     return 1;
  872. }
  873.  
  874. STATIC int
  875. f_include()
  876. {
  877.     string_t    *filename;
  878.     struct_t    *a;
  879.     int        rc;
  880.     file_t        *f;
  881.  
  882.     switch (NARGS())
  883.     {
  884.     case 1:
  885.     if (typecheck("o", &filename))
  886.         return 1;
  887.     a = structof(v_top[-1]);
  888.     got(a);
  889.     break;
  890.     case 2:
  891.     if (typecheck("od", &filename, &a))
  892.         return 1;
  893.     got(a);
  894.     break;
  895.     default:
  896.     return argcount(2);
  897.     }
  898.     if (!isstring(objof(filename)))
  899.     {
  900.     loose(a);
  901.     return argerror(0);
  902.     }
  903.     if ((error = ici_call("fopen", "o=o", &f, filename)) != NULL)
  904.     {
  905.     loose(a);
  906.     return 1;
  907.     }
  908.     rc = parse_module(f, a);
  909.     ici_call("close", "o", f);
  910.     if (rc < 0)
  911.     {
  912.     loose(a);
  913.     return 1;
  914.     }
  915.     return loose_ret(objof(a));    
  916. }
  917.  
  918. /*
  919.  * This calls the called function directly, after putting the args on
  920.  * the stack.
  921.  */
  922. STATIC int
  923. f_call()
  924. {
  925.     object_t    *o;
  926.     object_t    *aa;
  927.     int        nargs;
  928.  
  929.     if (typecheck("oo", &o, &aa))
  930.     return 1;
  931.     o_top -= 3; /* Two args plus us. */
  932.     if (!isarray(aa))
  933.     {
  934.     if (!isnull(aa))
  935.         return argerror(1);
  936.     nargs = 0;
  937.     }
  938.     else
  939.     {
  940.     object_t    **a;
  941.  
  942.     /*
  943.      * We include an extra 80 in our pushcheck, see start of ici_evaluate().
  944.      */
  945.     nargs = arrayof(aa)->a_top - arrayof(aa)->a_base;
  946.     if (pushcheck(os, nargs + 80))
  947.         return 1;
  948.     for (a = arrayof(aa)->a_top - 1; a >= arrayof(aa)->a_base; --a)
  949.         *o_top++ = *a;
  950.     }
  951.     if (pushcheck(os, 1))
  952.     return 1;
  953.     *o_top++ = o;
  954.     x_top[-1] = objof(new_op(NULL, OP_CALL, nargs));
  955.     loose(x_top[-1]);
  956.     return op_call();
  957. }
  958.  
  959. STATIC int
  960. f_fail()
  961. {
  962.     char    *s;
  963.  
  964.     if (typecheck("s", &s))
  965.     return 1;
  966.     if (chkbuf(strlen(s)))
  967.     return 1;
  968.     strcpy(buf, s);
  969.     error = buf;
  970.     return 1;
  971. }
  972.  
  973. STATIC int
  974. f_exit()
  975. {
  976.     object_t    *rc;
  977.     long    status;
  978.  
  979.     switch (NARGS())
  980.     {
  981.     case 0:
  982.     rc = objof(&o_null);
  983.     break;
  984.     case 1:
  985.     if (typecheck("o", &rc))
  986.     return 1;
  987.     break;
  988.     default:
  989.     return argcount(1);
  990.     }
  991.     if (isint(rc))
  992.     status = (int)intof(rc)->i_value;
  993.     else if (rc == objof(&o_null))
  994.     status = 0;
  995.     else if (isstring(rc))
  996.     {
  997.     if (stringof(rc)->s_nchars == 0)
  998.         status = 0;
  999.     else
  1000.     {
  1001.         fprintf(stderr, "exit: %s\n", stringof(rc)->s_chars);
  1002.         status = 1;
  1003.     }
  1004.     }
  1005.     else
  1006.     {
  1007.     return argerror(0);
  1008.     }
  1009.     wrapup();
  1010.     exit(status);
  1011.     /*NOTREACHED*/
  1012. }
  1013.  
  1014. #ifndef NO_BACKWARDS_COMPATIBILITY
  1015. STATIC int
  1016. f_smash()
  1017. {
  1018.     char        *s;
  1019.     char        *delim;
  1020.     register char    **p;
  1021.     register array_t    *sa;
  1022.     register char    **strs;
  1023.  
  1024.     if (typecheck("ss", &s, &delim))
  1025.     return 1;
  1026.     if (delim[0] == 0)
  1027.     {
  1028.     error = "bad delimiter string";
  1029.     return 1;
  1030.     }
  1031.     if ((strs = smash(s, delim[0])) == NULL)
  1032.     return 1;
  1033.     if ((sa = new_array()) == NULL)
  1034.     goto fail;
  1035.     if (pushcheck(sa, nptrs(strs)))
  1036.     goto fail;
  1037.     for (p = strs; *p != NULL; ++p)
  1038.     {
  1039.     if ((*sa->a_top = objof(get_cname(*p))) == NULL)
  1040.         goto fail;
  1041.     ++sa->a_top;
  1042.     }
  1043.     zfree((char *)strs);
  1044.     return obj_ret(objof(sa));
  1045.  
  1046. fail:
  1047.     if (sa != NULL)
  1048.     loose(sa);
  1049.     zfree((char *)strs);
  1050.     return 1;
  1051. }
  1052. #endif
  1053.  
  1054. STATIC int
  1055. f_vstack()
  1056. {
  1057.     return obj_ret(copy(vs));
  1058. }
  1059.  
  1060. STATIC int
  1061. f_tochar()
  1062. {
  1063.     long    i;
  1064.  
  1065.     if (typecheck("i", &i))
  1066.     return 1;
  1067.     buf[0] = i;
  1068.     return obj_ret(objof(new_name(buf, 1)));
  1069. }
  1070.  
  1071. STATIC int
  1072. f_toint()
  1073. {
  1074.     char    *s;
  1075.  
  1076.     if (typecheck("s", &s))
  1077.     return 1;
  1078.     return int_ret((long)(s[0] & 0xFF));
  1079. }
  1080.  
  1081. STATIC int
  1082. f_rand()
  1083. {
  1084.     static long    seed    = 1;
  1085.  
  1086.     if (NARGS() >= 1)
  1087.     {
  1088.     if (typecheck("i", &seed))
  1089.         return 1;
  1090.     }
  1091.     seed = seed * 1103515245 + 12345;
  1092.     return obj_ret(objof(new_float(((seed >> 16) & 0x7FFF) / 32767.0)));
  1093. }
  1094.  
  1095. STATIC int
  1096. f_interval()
  1097. {
  1098.     object_t        *o;
  1099.     long        start;
  1100.     long        length;
  1101.     long        nel;
  1102.     register string_t    *s = 0; /* init to shut up compiler */
  1103.     register array_t    *a = 0; /* init to shut up compiler */
  1104.     register array_t    *a1;
  1105.  
  1106.  
  1107.     if (typecheck("oi*", &o, &start))
  1108.     return 1;
  1109.     length = -1;
  1110.     if (NARGS() > 2)
  1111.     {
  1112.     if (!isint(ARG(2)))
  1113.         return argerror(2);
  1114.     if ((length = intof(ARG(2))->i_value) < 0)
  1115.         argerror(2);
  1116.     }
  1117.     switch (o->o_tcode)
  1118.     {
  1119.     case TC_STRING:
  1120.     s = stringof(o);
  1121.     nel = s->s_nchars;
  1122.     break;
  1123.  
  1124.     case TC_ARRAY:
  1125.     a = arrayof(o);
  1126.     nel = a->a_top - a->a_base;
  1127.     break;
  1128.  
  1129.     default:
  1130.     return argerror(0);
  1131.     }
  1132.  
  1133.     if (start < 0)
  1134.     {
  1135.     if ((start += nel) < 0)
  1136.         start = 0;
  1137.     }
  1138.     else if (start > nel)
  1139.     start = nel;
  1140.     if (length < 0)
  1141.     length = nel;
  1142.     if (start + length > nel)
  1143.     length = nel - start;
  1144.     
  1145.     if (o->o_tcode == TC_STRING)
  1146.     {
  1147.     return obj_ret(objof(new_name(s->s_chars + start, length)));
  1148.     }
  1149.     else
  1150.     {
  1151.     if ((a1 = new_array()) == NULL)
  1152.         return 1;
  1153.     if (pushcheck(a1, length))
  1154.     {
  1155.         loose(a1);
  1156.         return 1;
  1157.     }
  1158.     memcpy((char *)a1->a_base, (char *)(a->a_base + start),
  1159.         length * sizeof(object_t *));
  1160.     a1->a_top += length;
  1161.     return obj_ret(objof(a1));
  1162.     }
  1163. }
  1164.  
  1165. STATIC int
  1166. f_explode()
  1167. {
  1168.     register int    i;
  1169.     char        *s;
  1170.     array_t        *x;
  1171.  
  1172.     if (typecheck("s", &s))
  1173.     return 1;
  1174.     if ((x = new_array()) == NULL)
  1175.     return 1;
  1176.     if (pushcheck(x, i = stringof(ARG(0))->s_nchars))
  1177.     {
  1178.     loose(x);
  1179.     return 1;
  1180.     }
  1181.     while (--i >= 0)
  1182.     {
  1183.     if ((*x->a_top = objof(new_int(*s++ & 0xFFL))) == NULL)
  1184.     {
  1185.         loose(x);
  1186.         return 1;
  1187.     }
  1188.     loose(*x->a_top);
  1189.     ++x->a_top;
  1190.     }
  1191.     return obj_ret(objof(x));
  1192. }
  1193.  
  1194. STATIC int
  1195. f_implode()
  1196. {
  1197.     array_t        *a;
  1198.     register int    i;
  1199.     register object_t    **o;
  1200.  
  1201.     if (typecheck("a", &a))
  1202.     return 1;
  1203.     i = 0;
  1204.     for (o = a->a_base; o < a->a_top; ++o)
  1205.     {
  1206.     switch ((*o)->o_tcode)
  1207.     {
  1208.     case TC_INT:
  1209.         if (chkbuf(i))
  1210.         return 1;
  1211.         buf[i++] = intof(*o)->i_value;
  1212.         break;
  1213.  
  1214.     case TC_STRING:
  1215.         if (chkbuf(i + stringof(*o)->s_nchars))
  1216.         return 1;
  1217.         memcpy(&buf[i], stringof(*o)->s_chars, stringof(*o)->s_nchars);
  1218.         i += stringof(*o)->s_nchars;
  1219.         break;
  1220.     }
  1221.     }
  1222.     return obj_ret(objof(new_name(buf, i)));
  1223. }
  1224.  
  1225. STATIC int
  1226. f_sopen()
  1227. {
  1228.     file_t    *f;
  1229.     char    *str;
  1230.     char    *mode;
  1231.  
  1232.     mode = "r";
  1233.     if (typecheck(NARGS() > 1 ? "ss" : "s", &str, &mode))
  1234.     return 1;
  1235.     if (strcmp(mode, "r") != 0 && strcmp(mode, "rb") != 0)
  1236.     {
  1237.     chkbuf(strlen(mode) + 50);
  1238.     sprintf(buf, "attempt to use mode \"%s\" in sopen()", mode);
  1239.     error = buf;
  1240.     return 1;
  1241.     }
  1242.     if ((f = sopen(str, stringof(ARG(0))->s_nchars)) == NULL)
  1243.     return 1;
  1244.     f->f_name = get_cname("");
  1245.     return obj_ret(objof(f));
  1246. }
  1247.  
  1248. STATIC int
  1249. f_mopen()
  1250. {
  1251.     mem_t    *mem;
  1252.     file_t    *f;
  1253.     char    *mode;
  1254.  
  1255.     if (typecheck("os", &mem, &mode))
  1256.     {
  1257.     if (typecheck("o", &mem))
  1258.         return 1;
  1259.     mode = "r";
  1260.     }
  1261.     if (!ismem(objof(mem)))
  1262.     return argerror(0);
  1263.     if (strcmp(mode, "r") && strcmp(mode, "rb"))
  1264.     {
  1265.     error = "bad open mode for mopen";
  1266.     return 1;
  1267.     }
  1268.     if (mem->m_accessz != 1)
  1269.     {
  1270.     error = "memory object must have access size of 1 to be opened";
  1271.     return 1;
  1272.     }
  1273.     if ((f = sopen(mem->m_base, mem->m_length)) == NULL)
  1274.     return 1;
  1275.     f->f_name = get_cname("");
  1276.     return obj_ret(objof(f));
  1277. }
  1278.  
  1279. int
  1280. f_sprintf()
  1281. {
  1282.     char        *fmt;
  1283.     register char    *p;
  1284.     register int    i;        /* Where we are up to in buf. */
  1285.     register int    j;
  1286.     int            which;
  1287.     int            nargs;
  1288.     char        subfmt[40];    /* %...? portion of string. */
  1289.     int            stars[2];    /* Precision and field widths. */
  1290.     int            nstars;
  1291.     int            gotl;        /* Have a long int flag. */
  1292.     long        ivalue;
  1293.     double        fvalue;
  1294.     char        *svalue;
  1295.     object_t        **o;        /* Argument pointer. */
  1296.     file_t        *file;
  1297.     extern char        *strchr();
  1298. #ifdef    BAD_PRINTF_RETVAL
  1299. #define    IPLUSEQ
  1300. #else
  1301. #define    IPLUSEQ        i +=
  1302. #endif
  1303.  
  1304.     which = (int)CF_ARG1(); /* sprintf, printf, fprintf */
  1305.     if (which != 0 && NARGS() > 0 && isfile(ARG(0)))
  1306.     {
  1307.     which = 2;
  1308.     if (typecheck("us*", &file, &fmt))
  1309.         return 1;
  1310.     o = ARGS() - 2;
  1311.     nargs = NARGS() - 2;
  1312.     }
  1313.     else
  1314.     {
  1315.     if (typecheck("s*", &fmt))
  1316.         return 1;
  1317.     o = ARGS() - 1;
  1318.     nargs = NARGS() - 1;
  1319.     }
  1320.  
  1321.     p = fmt;
  1322.     i = 0;
  1323.     while (*p != '\0')
  1324.     {
  1325.     if (*p != '%')
  1326.     {
  1327.         if (chkbuf(i))
  1328.         return 1;
  1329.         buf[i++] = *p++;
  1330.         continue;
  1331.     }
  1332.  
  1333.     nstars = 0;
  1334.     gotl = 0;
  1335.     subfmt[0] = *p++;
  1336.     j = 1;
  1337.     while (*p != '\0' && strchr("diouxXfeEgGcs%", *p) == NULL)
  1338.     {
  1339.         if (*p == '*')
  1340.         ++nstars;
  1341.         else if (*p == 'l')
  1342.         gotl = 1;
  1343.         subfmt[j++] = *p++;
  1344.     }
  1345.     if (gotl == 0 && strchr("diouxXc", *p) != NULL)
  1346.         subfmt[j++] = 'l';
  1347.     subfmt[j++] = *p;
  1348.     subfmt[j++] = '\0';
  1349.     if (nstars > 2)
  1350.         nstars = 2;
  1351.     stars[0] = 0;
  1352.     stars[1] = 0;
  1353.     for (j = 0; j < nstars; ++j)
  1354.     {
  1355.         if (nargs <= 0)
  1356.         goto lacking;
  1357.         if (!isint(*o))
  1358.         goto type;
  1359.         stars[j] = intof(*o)->i_value;
  1360.         --o;
  1361.         --nargs;
  1362.     }
  1363.     switch (*p++)
  1364.     {
  1365.     case 'd':
  1366.     case 'i':
  1367.     case 'o':
  1368.     case 'u':
  1369.     case 'x':
  1370.     case 'X':
  1371.     case 'c':
  1372.         if (nargs <= 0)
  1373.         goto lacking;
  1374.         if (isint(*o))
  1375.         ivalue = intof(*o)->i_value;
  1376.         else if (isfloat(*o))
  1377.         ivalue = floatof(*o)->f_value;
  1378.         else
  1379.         goto type;
  1380.         if (chkbuf(i + 30)) /* Worst case. */
  1381.         return 1;
  1382.         switch (nstars)
  1383.         {
  1384.         case 0:
  1385.         IPLUSEQ sprintf(&buf[i], subfmt, ivalue);
  1386.         break;
  1387.  
  1388.         case 1:
  1389.         IPLUSEQ sprintf(&buf[i], subfmt, stars[0], ivalue);
  1390.         break;
  1391.  
  1392.         case 2:
  1393.         IPLUSEQ sprintf(&buf[i], subfmt, stars[0], stars[1], ivalue);
  1394.         break;
  1395.         }
  1396.         --o;
  1397.         --nargs;
  1398.         break;
  1399.  
  1400.     case 's':
  1401.         if (nargs <= 0)
  1402.         goto lacking;
  1403.         if (!isstring(*o))
  1404.         goto type;
  1405.         svalue = stringof(*o)->s_chars;
  1406.         if (chkbuf(i + stringof(*o)->s_nchars + stars[0] + stars[1]))
  1407.         return 1;
  1408.         switch (nstars)
  1409.         {
  1410.         case 0:
  1411.         IPLUSEQ sprintf(&buf[i], subfmt, svalue);
  1412.         break;
  1413.  
  1414.         case 1:
  1415.         IPLUSEQ sprintf(&buf[i], subfmt, stars[0], svalue);
  1416.         break;
  1417.  
  1418.         case 2:
  1419.         IPLUSEQ sprintf(&buf[i], subfmt, stars[0], stars[1], svalue);
  1420.         break;
  1421.         }
  1422.         --o;
  1423.         --nargs;
  1424.         break;
  1425.  
  1426.     case 'f':
  1427.     case 'e':
  1428.     case 'E':
  1429.     case 'g':
  1430.     case 'G':
  1431.         if (nargs <= 0)
  1432.         goto lacking;
  1433.         if (isint(*o))
  1434.         fvalue = intof(*o)->i_value;
  1435.         else if (isfloat(*o))
  1436.         fvalue = floatof(*o)->f_value;
  1437.         else
  1438.         goto type;
  1439.         if (chkbuf(i + 40)) /* Worst case. */
  1440.         return 1;
  1441.         switch (nstars)
  1442.         {
  1443.         case 0:
  1444.         IPLUSEQ sprintf(&buf[i], subfmt, fvalue);
  1445.         break;
  1446.  
  1447.         case 1:
  1448.         IPLUSEQ sprintf(&buf[i], subfmt, stars[0], fvalue);
  1449.         break;
  1450.  
  1451.         case 2:
  1452.         IPLUSEQ sprintf(&buf[i], subfmt, stars[0], stars[1], fvalue);
  1453.         break;
  1454.         }
  1455.         --o;
  1456.         --nargs;
  1457.         break;
  1458.  
  1459.     case '%':
  1460.         if (chkbuf(i))
  1461.         return 1;
  1462.         buf[i++] = '%';
  1463.         continue;
  1464.     }
  1465. #ifdef    BAD_PRINTF_RETVAL
  1466.     i = strlen(buf); /* BSD sprintf doesn't return usual value. */
  1467. #endif
  1468.     }
  1469.     buf[i] = '\0';
  1470.     switch (which)
  1471.     {
  1472.     case 1: /* printf */
  1473.     if ((file = need_stdout()) == NULL)
  1474.         return 1;
  1475.     case 2: /* fprintf */
  1476.     if (objof(file)->o_flags & F_CLOSED)
  1477.     {
  1478.         error = "write to closed file";
  1479.         return 1;
  1480.     }
  1481.     (*file->f_type->ft_write)(buf, i, file->f_file);
  1482.     return int_ret((long)i);
  1483.     
  1484.     default: /* sprintf */
  1485.     return str_ret(buf);
  1486.     }
  1487.  
  1488. type:
  1489.     sprintf(buf, "attempt to use a %s with a \"%s\" format in sprintf",
  1490.     (*o)->o_type->t_name, subfmt);
  1491.     error = buf;
  1492.     return 1;
  1493.  
  1494. lacking:
  1495.     error = "not enoughs args to sprintf";
  1496.     return 1;
  1497. }
  1498.  
  1499. STATIC int
  1500. f_currentfile()
  1501. {
  1502.     object_t    **o;
  1503.  
  1504.     for (o = x_top - 1; o >= xs->a_base; --o)
  1505.     {
  1506.     if (isparse(*o))
  1507.         return loose_ret(objof(parseof(*o)->p_file));
  1508.     }
  1509.     return loose_ret(objof(&o_null));
  1510. }
  1511.  
  1512. STATIC int
  1513. f_del()
  1514. {
  1515.     struct_t    *s;
  1516.     object_t    *o;
  1517.  
  1518.     if (typecheck("do", &s, &o))
  1519.     return 1;
  1520.     unassign_struct(s, o);
  1521.     return loose_ret(objof(&o_null));
  1522. }
  1523.  
  1524. STATIC int
  1525. super_loop(s)
  1526. struct_t    *s;
  1527. {
  1528.     set_t    *set;
  1529.  
  1530.     if ((set = new_set()) == NULL)
  1531.     return 1;
  1532.     while (s->s_super != NULL)
  1533.     {
  1534.     if (assign(set, s, objof(o_one)))
  1535.         goto fail;
  1536.     if (fetch(set, objof(s->s_super)) == objof(o_one))
  1537.     {
  1538.         error = "cycle in structure super chain";
  1539.         goto fail;
  1540.     }
  1541.     s = s->s_super;
  1542.     }
  1543.     loose(set);
  1544.     return 0;
  1545.  
  1546. fail:
  1547.     loose(set);
  1548.     return 1;
  1549. }
  1550.  
  1551. STATIC int
  1552. f_super()
  1553. {
  1554.     struct_t    *s;
  1555.     struct_t    *newsuper;
  1556.     struct_t    *oldsuper;
  1557.  
  1558.     if (typecheck("d*", &s))
  1559.     return 1;
  1560.  
  1561.     newsuper = oldsuper = s->s_super;
  1562.     if (NARGS() >= 2)
  1563.     {
  1564.     if (objof(s)->o_flags & O_ATOM)
  1565.     {
  1566.         error = "attempt to set super of an atomic struct";
  1567.         return 1;
  1568.     }
  1569.     if (isnull(ARG(1)))
  1570.         newsuper = NULL;
  1571.     else if (isstruct(ARG(1)))
  1572.         newsuper = structof(ARG(1));
  1573.     else
  1574.         return argerror(1);
  1575.     NEXT_VSVER;
  1576.     }
  1577.     s->s_super = newsuper;
  1578.     if (super_loop(s))
  1579.     {
  1580.     s->s_super = oldsuper;
  1581.     return 1;
  1582.     }
  1583.     if (oldsuper == NULL)
  1584.     return loose_ret(objof(&o_null));
  1585.     return loose_ret(objof(oldsuper));
  1586. }
  1587.  
  1588. STATIC int
  1589. f_scope()
  1590. {
  1591.     struct_t    *s;
  1592.  
  1593.     s = structof(v_top[-1]);
  1594.     if (NARGS() > 0)
  1595.     {
  1596.     if (typecheck("d", &v_top[-1]))
  1597.         return 1;
  1598.     }
  1599.     return loose_ret(objof(s));
  1600. }
  1601.  
  1602. STATIC int
  1603. f_isatom()
  1604. {
  1605.     object_t    *o;
  1606.  
  1607.     if (typecheck("o", &o))
  1608.     return 1;
  1609.     if (o->o_flags & O_ATOM)
  1610.     return loose_ret(objof(o_one));
  1611.     else
  1612.     return loose_ret(objof(o_zero));
  1613. }
  1614.  
  1615. STATIC int
  1616. f_alloc()
  1617. {
  1618.     long    length;
  1619.     int        accessz;
  1620.     char    *p;
  1621.  
  1622.     if (typecheck("i*", &length))
  1623.     return 1;
  1624.     if (length < 0)
  1625.     {
  1626.     error = "attempt to allocate negative amount";
  1627.     return 1;
  1628.     }
  1629.     if (NARGS() >= 2)
  1630.     {
  1631.     if
  1632.     (
  1633.         !isint(ARG(1))
  1634.         ||
  1635.         (
  1636.         (accessz = intof(ARG(1))->i_value) != 1
  1637.         &&
  1638.         accessz != 2
  1639.         &&
  1640.         accessz != 4
  1641.         )
  1642.     )
  1643.         return argerror(1);
  1644.     }
  1645.     else
  1646.     accessz = 1;
  1647.     if ((p = zalloc(length * accessz)) == NULL)
  1648.     return 1;
  1649.     memset(p, 0, length * accessz);
  1650.     return obj_ret(objof(new_mem(p, (unsigned long)length, accessz, ici_free)));
  1651. }
  1652.  
  1653. STATIC int
  1654. f_mem()
  1655. {
  1656.     long    base;
  1657.     long    length;
  1658.     int        accessz;
  1659.  
  1660.     if (typecheck("ii*", &base, &length))
  1661.     return 1;
  1662.     if (NARGS() >= 3)
  1663.     {
  1664.     if
  1665.     (
  1666.         !isint(ARG(2))
  1667.         ||
  1668.         (
  1669.         (accessz = intof(ARG(2))->i_value) != 1
  1670.         &&
  1671.         accessz != 2
  1672.         &&
  1673.         accessz != 4
  1674.         )
  1675.     )
  1676.         return argerror(2);
  1677.     }
  1678.     else
  1679.     accessz = 1;
  1680.     return obj_ret(objof(new_mem((char *)base, (unsigned long)length, accessz, NULL)));
  1681. }
  1682.  
  1683. STATIC int
  1684. f_assign()
  1685. {
  1686.     struct_t    *s;
  1687.     struct_t    *super;
  1688.     object_t    *k;
  1689.     object_t    *v;
  1690.     int        r;
  1691.  
  1692.     if (typecheck("doo", &s, &k, &v))
  1693.     return 1;
  1694.     if ((super = s->s_super) != NULL)
  1695.     got(super);
  1696.     s->s_super = NULL;
  1697.     r = assign(s, k, v);
  1698.     if ((s->s_super = super) != NULL)
  1699.     loose(super);
  1700.     if (r)
  1701.     return 1;
  1702.     return loose_ret(v);
  1703. }
  1704.  
  1705. STATIC int
  1706. f_fetch()
  1707. {
  1708.     struct_t    *s;
  1709.     struct_t    *super;
  1710.     object_t    *k;
  1711.     object_t    *v;
  1712.  
  1713.     if (typecheck("do", &s, &k))
  1714.     return 1;
  1715.     if ((super = s->s_super) != NULL)
  1716.     got(super);
  1717.     s->s_super = NULL;
  1718.     v = fetch(s, k);
  1719.     if ((s->s_super = super) != NULL)
  1720.     loose(super);
  1721.     return loose_ret(v);
  1722. }
  1723.  
  1724. #ifndef    NOWAITFOR
  1725. STATIC int
  1726. f_waitfor()
  1727. {
  1728.     register object_t    **e;
  1729.     int            nargs;
  1730.     fd_set        readfds;
  1731.     struct timeval    timeval;
  1732.     struct timeval    *tv;
  1733.     double        to;
  1734.     int            nfds;
  1735.     int            i;
  1736. #ifndef fileno
  1737.     extern int        fileno();
  1738. #endif
  1739.  
  1740.     if (NARGS() == 0)
  1741.     return loose_ret(objof(o_zero));
  1742.     tv = NULL;
  1743.     nfds = 0;
  1744.     FD_ZERO(&readfds);
  1745.     to = 0.0; /* Stops warnings, not required. */
  1746.     for (nargs = NARGS(), e = ARGS(); nargs > 0; --nargs, --e)
  1747.     {
  1748.     if (isfile(*e))
  1749.     {
  1750.         /*
  1751.          * If the ft_getch routine of the file is the real stdio fgetc,
  1752.          * we can assume the file is a real stdio stream file, then
  1753.          * we also assume we can use fileno on it.
  1754.          */
  1755.         if (fileof(*e)->f_type->ft_getch == fgetc)
  1756.         {
  1757.         setvbuf((FILE *)fileof(*e)->f_file, NULL, _IONBF, 0);
  1758.         i = fileno((FILE *)fileof(*e)->f_file);
  1759.         FD_SET(i, &readfds);
  1760.         if (i >= nfds)
  1761.             nfds = i + 1;
  1762.         }
  1763.         else
  1764.         return loose_ret(*e);
  1765.     }
  1766.     else if (isint(*e))
  1767.     {
  1768.         if (tv == NULL || to > intof(*e)->i_value / 1000.0)
  1769.         {
  1770.         to = intof(*e)->i_value / 1000.0;
  1771.         tv = &timeval;
  1772.         }
  1773.     }
  1774.     else if (isfloat(*e))
  1775.     {
  1776.         if (tv == NULL || to > floatof(*e)->f_value)
  1777.         {
  1778.         to = floatof(*e)->f_value;
  1779.         tv = &timeval;
  1780.         }
  1781.     }
  1782.     else
  1783.         return argerror(ARGS() - e);
  1784.     }
  1785.     if (tv != NULL)
  1786.     {
  1787.     tv->tv_sec = to;
  1788.     tv->tv_usec = (to - tv->tv_sec) * 1000000.0;
  1789.     }
  1790.     switch (select(nfds, &readfds, NULL, NULL, tv))
  1791.     {
  1792.     case -1:
  1793.     error = "could not select";
  1794.     return 1;
  1795.  
  1796.     case 0:
  1797.     return loose_ret(objof(o_zero));
  1798.     }
  1799.     for (nargs = NARGS(), e = ARGS(); nargs > 0; --nargs, --e)
  1800.     {
  1801.     if (!isfile(*e))
  1802.         continue;
  1803.     if (fileof(*e)->f_type->ft_getch == fgetc)
  1804.     {
  1805.         i = fileno((FILE *)fileof(*e)->f_file);
  1806.         if (FD_ISSET(i, &readfds))
  1807.         return loose_ret(*e);
  1808.     }
  1809.     }
  1810.     error = "no file selected";
  1811.     return 1;
  1812. }
  1813. #endif
  1814.  
  1815. STATIC int
  1816. f_gettoken()
  1817. {
  1818.     file_t        *f;
  1819.     string_t        *s;
  1820.     unsigned char    *seps;
  1821.     int            nseps;
  1822.     char        *file;
  1823.     int            (*get)();
  1824.     int            c;
  1825.     int            i;
  1826.     int            j;
  1827.  
  1828.     seps = (unsigned char *) " \t\n";
  1829.     nseps = 3;
  1830.     switch (NARGS())
  1831.     {
  1832.     case 0:
  1833.     if ((f = need_stdin()) == NULL)
  1834.         return 1;
  1835.     break;
  1836.  
  1837.     case 1:
  1838.     if (typecheck("o", &f))
  1839.         return 1;
  1840.     if (isstring(objof(f)))
  1841.     {
  1842.         if ((f = sopen(stringof(f)->s_chars, stringof(f)->s_nchars)) == NULL)
  1843.         return 1;
  1844.         loose(f);
  1845.     }
  1846.     else if (!isfile(objof(f)))
  1847.         return argerror(0);
  1848.     break;
  1849.  
  1850.     default:
  1851.     if (typecheck("oo", &f, &s))
  1852.         return 1;
  1853.     if (isstring(objof(f)))
  1854.     {
  1855.         if ((f = sopen(stringof(f)->s_chars, stringof(f)->s_nchars)) == NULL)
  1856.         return 1;
  1857.         loose(f);
  1858.     }
  1859.     else if (!isfile(objof(f)))
  1860.         return argerror(0);
  1861.     if (!isstring(objof(s)))
  1862.         return argerror(1);
  1863.     seps = (unsigned char *)s->s_chars;
  1864.     nseps = s->s_nchars;
  1865.     break;
  1866.     }
  1867.     get = f->f_type->ft_getch;
  1868.     file = f->f_file;
  1869.     do
  1870.     {
  1871.     c = (*get)(file);
  1872.     if (c == EOF)
  1873.         return loose_ret(objof(&o_null));
  1874.     for (i = 0; i < nseps; ++i)
  1875.     {
  1876.         if (c == seps[i])
  1877.         break;
  1878.     }
  1879.  
  1880.     } while (i != nseps);
  1881.  
  1882.     j = 0;
  1883.     do
  1884.     {
  1885.     chkbuf(j);
  1886.     buf[j++] = c;
  1887.     c = (*get)(file);
  1888.     if (c == EOF)
  1889.         break;
  1890.     for (i = 0; i < nseps; ++i)
  1891.     {
  1892.         if (c == seps[i])
  1893.         {
  1894.         (*f->f_type->ft_ungetch)(c, file);
  1895.         break;
  1896.         }
  1897.     }
  1898.  
  1899.     } while (i == nseps);
  1900.  
  1901.     if ((s = new_name(buf, j)) == NULL)
  1902.     return 1;
  1903.     return obj_ret(objof(s));
  1904. }
  1905.  
  1906. STATIC int
  1907. f_gettokens()
  1908. {
  1909.     file_t        *f;
  1910.     string_t        *s;
  1911.     unsigned char    *terms;
  1912.     int            nterms;
  1913.     unsigned char    *seps;
  1914.     int            nseps;
  1915.     unsigned char    *delims = 0; /* init to shut up compiler */
  1916.     int            ndelims;
  1917.     int            hardsep;
  1918.     unsigned char    sep;
  1919.     char        *file;
  1920.     array_t        *a;
  1921.     int            (*get)();
  1922.     int            c;
  1923.     int            i;
  1924.     int            j = 0; /* init to shut up compiler */
  1925.     int            state;
  1926.     int            what;
  1927.     int            loose_it = 0;
  1928.  
  1929.     seps = (unsigned char *)" \t";
  1930.     nseps = 2;
  1931.     hardsep = 0;
  1932.     terms = (unsigned char *)"\n";
  1933.     nterms = 1;
  1934.     ndelims = 0;
  1935.     switch (NARGS())
  1936.     {
  1937.     case 0:
  1938.     if ((f = need_stdin()) == NULL)
  1939.         return 1;
  1940.     break;
  1941.  
  1942.     case 1:
  1943.     if (typecheck("o", &f))
  1944.         return 1;
  1945.     if (isstring(objof(f)))
  1946.     {
  1947.         if ((f = sopen(stringof(f)->s_chars, stringof(f)->s_nchars)) == NULL)
  1948.         return 1;
  1949.         loose_it = 1;
  1950.     }
  1951.     else if (!isfile(objof(f)))
  1952.         return argerror(0);
  1953.     break;
  1954.  
  1955.     case 2:
  1956.     case 3:
  1957.     case 4:
  1958.     if (typecheck("oo*", &f, &s))
  1959.         return 1;
  1960.     if (isstring(objof(f)))
  1961.     {
  1962.         if ((f = sopen(stringof(f)->s_chars, stringof(f)->s_nchars)) == NULL)
  1963.         return 1;
  1964.         loose_it = 1;
  1965.     }
  1966.     else if (!isfile(objof(f)))
  1967.         return argerror(0);
  1968.     if (isint(objof(s)))
  1969.     {
  1970.         sep = intof(objof(s))->i_value;
  1971.         hardsep = 1;
  1972.         seps = (unsigned char *)&sep;
  1973.         nseps = 1;
  1974.     }
  1975.     else if (isstring(objof(s)))
  1976.     {
  1977.         seps = (unsigned char *)s->s_chars;
  1978.         nseps = s->s_nchars;
  1979.     }
  1980.     else
  1981.     {
  1982.         if (loose_it)
  1983.         loose(f);
  1984.         return argerror(1);
  1985.     }
  1986.     if (NARGS() > 2)
  1987.     {
  1988.         if (!isstring(ARG(2)))
  1989.         {
  1990.         if (loose_it)
  1991.             loose(f);
  1992.         return argerror(2);
  1993.         }
  1994.         terms = (unsigned char *)stringof(ARG(2))->s_chars;
  1995.         nterms = stringof(ARG(2))->s_nchars;
  1996.         if (NARGS() > 3)
  1997.         {
  1998.         if (!isstring(ARG(3)))
  1999.         {
  2000.             if (loose_it)
  2001.             loose(f);
  2002.             return argerror(3);
  2003.         }
  2004.         delims = (unsigned char *)stringof(ARG(3))->s_chars;
  2005.         ndelims = stringof(ARG(3))->s_nchars;
  2006.         }
  2007.     }
  2008.     break;
  2009.  
  2010.     default:
  2011.     return argcount(3);
  2012.     }
  2013.     get = f->f_type->ft_getch;
  2014.     file = f->f_file;
  2015.  
  2016. #define    S_IDLE    0
  2017. #define    S_INTOK    1
  2018.  
  2019. #define    W_EOF    0
  2020. #define    W_SEP    1
  2021. #define    W_TERM    2
  2022. #define    W_TOK    3
  2023. #define    W_DELIM    4
  2024.  
  2025.     state = S_IDLE;
  2026.     if ((a = new_array()) == NULL)
  2027.     goto fail;
  2028.     for (;;)
  2029.     {
  2030.     /*
  2031.      * Get the next character and classify it.
  2032.      */
  2033.     if ((c = (*get)(file)) == EOF)
  2034.     {
  2035.         what = W_EOF;
  2036.         goto got_what;
  2037.     }
  2038.     for (i = 0; i < nseps; ++i)
  2039.     {
  2040.         if (c == seps[i])
  2041.         {
  2042.         what = W_SEP;
  2043.         goto got_what;
  2044.         }
  2045.     }
  2046.     for (i = 0; i < nterms; ++i)
  2047.     {
  2048.         if (c == terms[i])
  2049.         {
  2050.         what = W_TERM;
  2051.         goto got_what;
  2052.         }
  2053.     }
  2054.     for (i = 0; i < ndelims; ++i)
  2055.     {
  2056.         if (c == delims[i])
  2057.         {
  2058.         what = W_DELIM;
  2059.         goto got_what;
  2060.         }
  2061.     }
  2062.     what = W_TOK;
  2063.     got_what:
  2064.  
  2065.     /*
  2066.      * Act on state and current character classification.
  2067.      */
  2068.     switch ((state << 8) + what)
  2069.     {
  2070.     case (S_IDLE << 8) + W_EOF:
  2071.         if (loose_it)
  2072.         loose(f);
  2073.         if (a->a_top == a->a_base)
  2074.         {
  2075.         loose(a);
  2076.         return loose_ret(objof(&o_null));
  2077.         }
  2078.         return obj_ret(objof(a));
  2079.  
  2080.     case (S_IDLE << 8) + W_TERM:
  2081.         if (!hardsep)
  2082.         {
  2083.         if (loose_it)
  2084.             loose(f);
  2085.         return obj_ret(objof(a));
  2086.         }
  2087.         j = 0;
  2088.     case (S_INTOK << 8) + W_EOF:
  2089.     case (S_INTOK << 8) + W_TERM:
  2090.         if (pushcheck(a, 1))
  2091.         goto fail;
  2092.         if ((s = new_name(buf, j)) == NULL)
  2093.         goto fail;
  2094.         *a->a_top++ = objof(s);
  2095.         if (loose_it)
  2096.         loose(f);
  2097.         loose(s);
  2098.         return obj_ret(objof(a));
  2099.  
  2100.     case (S_IDLE << 8) + W_SEP:
  2101.         if (!hardsep)
  2102.         break;
  2103.         j = 0;
  2104.     case (S_INTOK << 8) + W_SEP:
  2105.         if (pushcheck(a, 1))
  2106.         goto fail;
  2107.         if ((s = new_name(buf, j)) == NULL)
  2108.         goto fail;
  2109.         *a->a_top++ = objof(s);
  2110.         loose(s);
  2111.         if (hardsep)
  2112.         {
  2113.         j = 0;
  2114.         state = S_INTOK;
  2115.         }
  2116.         else
  2117.         state = S_IDLE;
  2118.         break;
  2119.  
  2120.     case (S_INTOK << 8) + W_DELIM:
  2121.         if (pushcheck(a, 1))
  2122.         goto fail;
  2123.         if ((s = new_name(buf, j)) == NULL)
  2124.         goto fail;
  2125.         *a->a_top++ = objof(s);
  2126.         loose(s);
  2127.     case (S_IDLE << 8) + W_DELIM:
  2128.         if (pushcheck(a, 1))
  2129.         goto fail;
  2130.         buf[0] = c;
  2131.         if ((s = new_name(buf, 1)) == NULL)
  2132.         goto fail;
  2133.         *a->a_top++ = objof(s);
  2134.         loose(s);
  2135.         j = 0;
  2136.         state = S_IDLE;
  2137.         break;
  2138.         
  2139.     case (S_IDLE << 8) + W_TOK:
  2140.         j = 0;
  2141.         state = S_INTOK;
  2142.     case (S_INTOK << 8) + W_TOK:
  2143.         if (chkbuf(j))
  2144.         goto fail;
  2145.         buf[j++] = c;
  2146.     }
  2147.     }
  2148.  
  2149. fail:
  2150.     if (loose_it)
  2151.     loose(f);
  2152.     if (a != NULL)
  2153.     loose(a);
  2154.     return 1;
  2155. }
  2156.  
  2157. STATIC string_t *
  2158. do_sub(str, re, repl)
  2159. string_t    *str;
  2160. regexp_t    *re;
  2161. char        *repl;
  2162. {
  2163.     char     *dst;
  2164.     int         normal;
  2165.     char     *p;
  2166.     string_t *rc;
  2167.     int         len;
  2168.     char     *d;
  2169.  
  2170.     /*
  2171.      * Match the regexp against the input string.
  2172.      */
  2173.     if (!regexec(re->r_re, stringof(str)->s_chars))
  2174.     return NULL;
  2175.  
  2176.     /*
  2177.      * The string is divided into three parts. The bit before the matched
  2178.      * regexp, the matched section and anything that follows. We want to
  2179.      * determine the size of the actual output string so we can allocate
  2180.      * some space for it.
  2181.      */
  2182.  
  2183. #define START(n) re->r_re->startp[n]
  2184. #define END(n)   re->r_re->endp[n]
  2185.  
  2186.     len = stringof(str)->s_nchars - (END(0) - START(0));
  2187.  
  2188.     /*
  2189.      * Determine size of matched area. This depends on the replacement
  2190.      * text. If there are any \& or \nnn sequences these must be
  2191.      * replaced by the appropriate section of the input string.
  2192.      */
  2193.     for (normal = 1, p = repl; *p != 0; ++p)
  2194.     {
  2195.     int c = *p;
  2196.     if (normal)
  2197.     {
  2198.         if (c == '\\')
  2199.         normal = 0;
  2200.         else
  2201.         ++len;
  2202.     }
  2203.     else
  2204.     {
  2205.         normal = 1;
  2206.         if (!isdigit(c))
  2207.         len += 2;
  2208.         else
  2209.         {
  2210.         c -= '0';
  2211.         if (START(c) != NULL)
  2212.             len += END(c) - START(c);
  2213.         }
  2214.     }
  2215.     }
  2216.     /*
  2217.      * Now get that much space and stuff it with the string.
  2218.      */
  2219.     if ((dst = zalloc(len)) == NULL)
  2220.     return (string_t *)-1;
  2221.     memcpy(dst, stringof(str)->s_chars, START(0) - stringof(str)->s_chars);
  2222.     d = &dst[START(0) - stringof(str)->s_chars];
  2223.     for (normal = 1, p = repl; *p != 0; ++p)
  2224.     {
  2225.     int c = *p;
  2226.     if (normal)
  2227.     {
  2228.         if (c == '\\')
  2229.         normal = 0;
  2230.         else
  2231.         *d++ = c;
  2232.     }
  2233.     else
  2234.     {
  2235.         normal = 1;
  2236.         c -= '0';
  2237.         if (!isdigit(c))
  2238.         {
  2239.         *d++ = '\\';
  2240.         *d++ = c;
  2241.         }
  2242.         else
  2243.         {
  2244.             strncpy(d, START(c), END(c) - START(c));
  2245.             d += END(c) - START(c);
  2246.         }
  2247.     }
  2248.     }
  2249.     *d = 0;
  2250.     strncpy(d, END(0), (stringof(str)->s_chars + stringof(str)->s_nchars) - END(0) + 1);
  2251.     rc = new_cname(dst);
  2252.     zfree(dst);
  2253.     if (rc == NULL)
  2254.     return (string_t *)-1;
  2255.     return rc;
  2256.  
  2257. #undef START
  2258. #undef END
  2259.  
  2260. }
  2261.  
  2262. STATIC int
  2263. f_sub()
  2264. {
  2265.     object_t    *str;
  2266.     object_t    *o;
  2267.     regexp_t    *re;
  2268.     char    *repl;
  2269.     string_t    *rc;
  2270.  
  2271.     /*
  2272.      * Get the ICI arguments.
  2273.      */
  2274.     if (typecheck("oos", &str, &o, &repl))
  2275.     return 1;
  2276.     if (!isstring(str))
  2277.     return argerror(0);
  2278.     if (isregexp(o))
  2279.     re = regexpof(o);
  2280.     else if (!isstring(o))
  2281.     return argerror(1);
  2282.     else if ((re = new_regexp(stringof(o)->s_chars)) == NULL)
  2283.     return 1;
  2284.  
  2285.     if ((rc = do_sub(str, re, repl)) == NULL)
  2286.     rc = stringof(str);
  2287.     else if (rc == (string_t*)-1)
  2288.     return 1;
  2289.  
  2290.     return loose_ret(objof(rc));
  2291. }
  2292.  
  2293. STATIC int
  2294. f_gsub()
  2295. {
  2296.     object_t    *str;
  2297.     object_t    *o;
  2298.     regexp_t    *re;
  2299.     char    *repl;
  2300.     string_t    *rc;
  2301.  
  2302.     /*
  2303.      * Get the ICI arguments.
  2304.      */
  2305.     if (typecheck("oos", &str, &o, &repl))
  2306.     return 1;
  2307.     if (!isstring(str))
  2308.     return argerror(0);
  2309.     if (isregexp(o))
  2310.     re = regexpof(o);
  2311.     else if (!isstring(o))
  2312.     return argerror(1);
  2313.     else if ((re = new_regexp(stringof(o)->s_chars)) == NULL)
  2314.     return 1;
  2315.  
  2316.     do
  2317.     {
  2318.     if ((rc = do_sub(str, re, repl)) == (string_t *)-1)
  2319.         return 1;
  2320.     else if (rc != NULL)
  2321.         str = objof(rc);
  2322.     }
  2323.     while (rc != NULL);
  2324.  
  2325.     return loose_ret(objof(str));
  2326. }
  2327.  
  2328. /*
  2329.  * sort(array, cmp)
  2330.  */
  2331. static int 
  2332. f_sort()
  2333. {
  2334.     array_t    *a;
  2335.     object_t    **base;
  2336.     long    n;
  2337.     func_t    *f;
  2338.     long    cmp;
  2339.     long    k;                /* element added or removed */
  2340.     long    p;                /* place in heap */
  2341.     long    q;                /* place in heap */
  2342.     long    l;                /* left child */
  2343.     long    r;                /* right child */
  2344.     object_t    *o;                /* object used for swapping */
  2345. /*
  2346.  * Relations within heap.
  2347.  */
  2348. #define    PARENT(i)    (((i) - 1) >> 1)
  2349. #define    LEFT(i)        ((i) + (i) + 1)
  2350. #define    RIGHT(i)    ((i) + (i) + 2)
  2351. /*
  2352.  * Macro for swapping elements.
  2353.  */
  2354. #define SWAP(a, b)    {o = base[a]; base[a] = base[b]; base[b] = o;}
  2355. #define    CMP(rp, a, b)    ici_func(objof(f), "i=oo", rp, base[a], base[b])
  2356.     
  2357.     if (typecheck("ao", &a, &f))
  2358.     return 1;
  2359.     if (!isfunc(objof(f)))
  2360.     return argerror(1);
  2361.     if (objof(a)->o_flags & O_ATOM)
  2362.     {
  2363.     error = "attempt to sort an atomic array";
  2364.     return 1;
  2365.     }
  2366.     base = a->a_base;
  2367.     n = a->a_top - base;
  2368.  
  2369.     /*
  2370.      * Shuffle heap.
  2371.      */
  2372.     for (k = 1; k < n; ++k)
  2373.     {
  2374.     p = k;
  2375.     while (p != 0)
  2376.     {
  2377.         q = PARENT(p);
  2378.         if (CMP(&cmp, p, q) != NULL)
  2379.         goto fail;
  2380.         if (cmp <= 0)
  2381.         break;
  2382.         SWAP(p, q);
  2383.         p = q;
  2384.     }
  2385.     }
  2386.  
  2387.     /*
  2388.      * Keep taking elements off heap and re-shuffling.
  2389.      */
  2390.     for (k = n - 1; k > 0; --k)
  2391.     {
  2392.     SWAP(0, k);
  2393.     p = 0;
  2394.     while (1)
  2395.     {
  2396.         l = LEFT(p);
  2397.         if (l >= k)
  2398.         break;
  2399.         r = RIGHT(p);
  2400.         if (r >= k)
  2401.         {
  2402.         if (CMP(&cmp, l, p) != NULL)
  2403.             goto fail;
  2404.         if (cmp <= 0)
  2405.             break;
  2406.         SWAP(l, p);
  2407.         p = l;
  2408.         }
  2409.         else
  2410.         {
  2411.         if (CMP(&cmp, l, p) != NULL)
  2412.             goto fail;
  2413.         if (cmp <= 0)
  2414.         {
  2415.             if (CMP(&cmp, r, p) != NULL)
  2416.             goto fail;
  2417.             if (cmp <= 0)
  2418.             break;
  2419.             SWAP(r, p);
  2420.             p = r;
  2421.         }
  2422.         else
  2423.         {
  2424.             if (CMP(&cmp, r, l) != NULL)
  2425.             goto fail;
  2426.             if (cmp <= 0)
  2427.             {
  2428.             SWAP(l, p);
  2429.             p = l;
  2430.             }
  2431.             else
  2432.             {
  2433.             SWAP(r, p);
  2434.             p = r;
  2435.             }
  2436.         }
  2437.         }
  2438.     }
  2439.     }
  2440.     return loose_ret(objof(&o_null));
  2441.  
  2442. fail:
  2443.     return 1;
  2444.  
  2445. #undef    PARENT
  2446. #undef    LEFT
  2447. #undef    RIGHT
  2448. #undef    SWAP
  2449. }
  2450.  
  2451. f_reclaim()
  2452. {
  2453.     ici_reclaim();
  2454.     return loose_ret(objof(&o_null));
  2455. }
  2456.  
  2457. int
  2458. def_cfuncs(cf)
  2459. register cfunc_t    *cf;
  2460. {
  2461.     register string_t    *n;
  2462.  
  2463.     while (cf->cf_name != NULL)
  2464.     {
  2465.     if ((n = new_cname(cf->cf_name)) == NULL)
  2466.         return 1;
  2467.     if (assign(structof(v_top[-1])->s_super, n, cf))
  2468.     {
  2469.         loose(n);
  2470.         return 1;
  2471.     }
  2472.     loose(n);
  2473.     ++cf;
  2474.     }
  2475.     return 0;
  2476. }
  2477.  
  2478. cfunc_t    std_cfuncs[] =
  2479. {
  2480.     {CF_OBJ,    "array",    f_array},
  2481.     {CF_OBJ,    "copy",        f_copy},
  2482.     {CF_OBJ,    "exit",        f_exit},
  2483.     {CF_OBJ,    "fail",        f_fail},
  2484.     {CF_OBJ,    "float",    f_float},
  2485.     {CF_OBJ,    "int",        f_int},
  2486.     {CF_OBJ,    "eq",        f_eq},
  2487.     {CF_OBJ,    "parse",    f_parse},
  2488.     {CF_OBJ,    "regexp",    f_regexp},
  2489.     {CF_OBJ,    "sizeof",    f_nels},    /* Phaseing out, use nels. */
  2490.     {CF_OBJ,    "string",    f_string},
  2491.     {CF_OBJ,    "struct",    f_struct},
  2492.     {CF_OBJ,    "set",        f_set},
  2493.     {CF_OBJ,    "typeof",    f_typeof},
  2494.     {CF_OBJ,    "push",        f_push},
  2495.     {CF_OBJ,    "pop",        f_pop},
  2496.     {CF_OBJ,    "call",        f_call},
  2497.     {CF_OBJ,    "keys",        f_keys},
  2498.     {CF_OBJ,    "smash",    f_smash},
  2499.     {CF_OBJ,    "vstack",    f_vstack},
  2500.     {CF_OBJ,    "tochar",    f_tochar},
  2501.     {CF_OBJ,    "toint",    f_toint},
  2502.     {CF_OBJ,    "rand",        f_rand},
  2503.     {CF_OBJ,    "interval",    f_interval},
  2504.     {CF_OBJ,    "explode",    f_explode},
  2505.     {CF_OBJ,    "implode",    f_implode},
  2506.     {CF_OBJ,    "sopen",    f_sopen},
  2507.     {CF_OBJ,    "mopen",    f_mopen},
  2508.     {CF_OBJ,    "sprintf",    f_sprintf},
  2509.     {CF_OBJ,    "currentfile",    f_currentfile},
  2510.     {CF_OBJ,    "del",        f_del},
  2511.     {CF_OBJ,    "alloc",    f_alloc},
  2512.     {CF_OBJ,    "mem",        f_mem},
  2513.     {CF_OBJ,    "nels",        f_nels},
  2514.     {CF_OBJ,    "super",    f_super},
  2515.     {CF_OBJ,    "scope",    f_scope},
  2516.     {CF_OBJ,    "isatom",    f_isatom},
  2517.     {CF_OBJ,    "gettoken",    f_gettoken},
  2518.     {CF_OBJ,    "gettokens",    f_gettokens},
  2519.     {CF_OBJ,    "num",        f_num},
  2520.     {CF_OBJ,    "assign",    f_assign},
  2521.     {CF_OBJ,    "fetch",    f_fetch},
  2522. #ifndef    NOMATH
  2523.     {CF_OBJ,    "sin",        f_math, (int (*)())sin,        "f=n"},
  2524.     {CF_OBJ,    "cos",        f_math, (int (*)())cos,        "f=n"},
  2525.     {CF_OBJ,    "tan",        f_math, (int (*)())tan,        "f=n"},
  2526.     {CF_OBJ,    "asin",        f_math, (int (*)())asin,    "f=n"},
  2527.     {CF_OBJ,    "acos",        f_math, (int (*)())acos,    "f=n"},
  2528.     {CF_OBJ,    "atan",        f_math, (int (*)())atan,    "f=n"},
  2529.     {CF_OBJ,    "atan2",    f_math, (int (*)())atan2,    "f=nn"},
  2530.     {CF_OBJ,    "exp",        f_math, (int (*)())exp,        "f=n"},
  2531.     {CF_OBJ,    "log",        f_math, (int (*)())log,        "f=n"},
  2532.     {CF_OBJ,    "log10",    f_math, (int (*)())log10,    "f=n"},
  2533.     {CF_OBJ,    "pow",        f_math, (int (*)())pow,        "f=nn"},
  2534.     {CF_OBJ,    "sqrt",        f_math, (int (*)())sqrt,    "f=n"},
  2535.     {CF_OBJ,    "floor",    f_math, (int (*)())floor,    "f=n"},
  2536.     {CF_OBJ,    "ceil",        f_math, (int (*)())ceil,    "f=n"},
  2537.     {CF_OBJ,    "fmod",        f_math, (int (*)())fmod,    "f=nn"},
  2538. #endif
  2539. #ifndef    NOWAITFOR
  2540.     {CF_OBJ,    "waitfor",    f_waitfor},
  2541. #endif
  2542.     {CF_OBJ,    "top",        f_top},
  2543.     {CF_OBJ,    "include",    f_include},
  2544.     {CF_OBJ,    "sub",        f_sub},
  2545.     {CF_OBJ,    "gsub",        f_gsub},
  2546.     {CF_OBJ,    "sort",        f_sort},
  2547. #ifdef    WHOALLOC
  2548.     {CF_OBJ,    "reclaim",    f_reclaim},
  2549. #endif
  2550.     {CF_OBJ}
  2551. };
  2552.